;;; -*-LISP-*-  ARRAY OBJECTS

(HERALD ARRAY "")

(eval-when (compile) (load "scm:umacro"))
(eval-when (compile) (load "scm:smacro"))

(DEFMACRO ARRAY? (OBJECT)
  `(AND (HUNKP ,OBJECT) (EQ (OBJECT-TYPE ,OBJECT) '*ARRAY*)))

(DEFMACRO ARRAY-PTR (ARRAY)
  `(CXR 0 ,ARRAY))

(DEFMACRO ARRAY-DIMENSIONS (ARRAY)
  `(CXR 2 ,ARRAY))

(DEFUN MAKE-ARRAY-PTR (DIMENSIONS)
  (APPLY #'*ARRAY `(NIL T ,@DIMENSIONS)))

(DEFUN ARRAY-FETCH (PTR SUBSCRIPTS)
  (APPLY #'ARRAYCALL `(T ,PTR ,@SUBSCRIPTS)))

(DEFUN ARRAY-STORE (PTR SUBSCRIPTS VALUE)
  (STORE (APPLY #'ARRAYCALL `(T ,PTR ,@SUBSCRIPTS)) VALUE))

(DEFUN-IMPORT MAKE-ARRAY-OBJECT (DIMENSIONS INIT-PROC)
  (HUNK '*ARRAY*
	DIMENSIONS
	INIT-PROC
	(MAKE-ARRAY-PTR DIMENSIONS)))

(DEFUN-IMPORT (ACCESS-ARRAY SCHAREF) (ARRAY COORDINATES)
  (OR (ARRAY? ARRAY)
      (SCH-ERROR "Non-Array -- AREF" ARRAY))
  (ARRAY-FETCH (ARRAY-PTR ARRAY) COORDINATES))

(DEFUN-IMPORT (SET!-ARRAY SCHASET BUT-1-FORCED-SUBR) (ARRAY COORDINATES VALUE)
  (COND ((ARRAY? ARRAY)
	 (ARRAY-STORE (ARRAY-PTR ARRAY) COORDINATES VALUE))
	(T
	 (SCH-ERROR "Non-Array -- ASET" ARRAY))))

(DEFUN-IMPORT (DIMENSIONS-ARRAY SCHARRAYDIMS) (OBJECT)
       (OR (ARRAY? OBJECT)
	   (SCH-ERROR "Non-Array -- ARRAYDIMS" OBJECT))
       (ARRAY-DIMENSIONS OBJECT))

(DEFUN-IMPORT (ARRAY? SCHARRAY?) (OBJECT)
  (ARRAY? OBJECT))

;;; Property Lists

(DEFUN SCH-PLIST-1 (KNOWN-SYM)
  (CDR (GET KNOWN-SYM 'SCH-PROPERTY-LIST)))

(DEFUN-IMPORT LIST-PROP (SYM)
  (COND ((SYMBOLP SYM)
	 (ASSOCIATE (SCH-PLIST-1 SYM)))
	(T
	 (SCH-ERROR "Non-Symbolic Property Holder -- PLIST" (LIST 'PLIST SYM)))))

(DEFUN-IMPORT REMOVE!-PROP (SYM SLOT)
  (COND ((SYMBOLP SYM)
	 (LET ((OLD-VAL (GET-PROP SYM SLOT)))
	   (REMPROP (GET SYM 'SCH-PROPERTY-LIST) SLOT)
	   OLD-VAL))
	(T
	 (SCH-ERROR "Non-Symbolic Property Holder -- REMOVE!-PROP"
		(LIST 'REMOVE!-PROP SYM SLOT)))))

(DEFUN-IMPORT (PUT!-PROP PUT!-PROP BUT-1-FORCED-SUBR) (SYM SLOT VAL)
  (COND ((SYMBOLP SYM)
	 (LET ((PROPERTY-LIST (GET SYM 'SCH-PROPERTY-LIST)))
	   (COND (PROPERTY-LIST
		  (PUTPROP PROPERTY-LIST VAL SLOT))
		 (T
		  (PUTPROP SYM (LIST () SLOT VAL) 'SCH-PROPERTY-LIST)))
	   VAL))
	(T
	 (SCH-ERROR "Non-Symbolic Property Holder -- PUT!-PROP"
		(LIST 'PUT!-PROP SYM SLOT VAL)))))

(DEFUN-IMPORT GET-PROP (SYM SLOT)
  (COND ((SYMBOLP SYM)
	 (DO ((L (SCH-PLIST-1 SYM) (CDDR L)))
	     ((NULL L) ())
	   (IF (EQ SLOT (CAR L))
	       (RETURN (CADR L)))))
	(T
	 (SCH-ERROR "Non-Symbolic Property Holder -- GET-PROP"
		(LIST 'GET-PROP SYM SLOT)))))

;;;; Compound names.

;;; (value-compound-name <env> <name>) ===> <value>		;lexical lookup
;;; (assign!-compound-name <env> <name> <value>)		;lexical assign
;;; (define!-compound-name <env> <name> <value>)		;local define


(defun-import value-compound-name (env name)
  (relative-lexical-access env (canonicalize-compound-name name)))

(defun-import (assign!-compound-name assign!-compound-name but-1-forced-subr)
  (env name value)
  (relative-lexical-assign env (canonicalize-compound-name name) value))

(defun-import (define!-compound-name define!-compound-name but-1-forced-subr)
  (env name value)
  (local-define! env (canonicalize-compound-name name) value))


(defvar canonicalization-tree (list '*compound-name-tree* nil))

(defun-import canonicalize-compound-name (name)
  (let ((place (walk-discrimination-tree name canonicalization-tree)))
    (if (null (cadr place))
	(let ((newname (make-new-canonical-name name)))
	  (rplaca (cdr place) newname)
	  newname))
    (cadr place)))

(defun walk-discrimination-tree (name tree)
  (if (null name)
      tree
      (walk-discrimination-tree (cdr name)
				(find-subtree (car name) tree))))

(defun find-subtree (component tree)
  (let ((subtree (assq component (cddr tree))))
	(if (null subtree)
	    (progn (setq subtree (list component nil))
		   (rplacd (cdr tree)
			   (cons subtree (cddr tree)))))
	subtree))

(defun make-new-canonical-name (l)
  (list l))